Attribute VB_Name = "modDatabase"
'    Copyright 2010 ScriptWisdom
'    This file is part of the Greentail Engine.
'
'    Greentail Engine is free software: you can redistribute it and/or modify
'    it under the terms of the GNU General Public License as published by
'    the Free Software Foundation, either version 3 of the License, or
'    (at your option) any later version.
'
'    Greentail Engine is distributed in the hope that it will be useful,
'    but WITHOUT ANY WARRANTY; without even the implied warranty of
'    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
'    GNU General Public License for more details.
'
'    You should have received a copy of the GNU General Public License
'    along with Greentail Engine.  If not, see <http://www.gnu.org/licenses/>.

Option Explicit

Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationname As String, ByVal lpKeyname As Any, ByVal lpString As String, ByVal lpfilename As String) As Long
Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationname As String, ByVal lpKeyname As Any, ByVal lpdefault As String, ByVal lpreturnedstring As String, ByVal nsize As Long, ByVal lpfilename As String) As Long

Public START_MAP As Long
Public START_X As Long
Public START_Y As Long

Public temp As Integer

Public Const ADMIN_LOG = "logs\admin.txt"
Public Const PLAYER_LOG = "logs\player.txt"

'Database Stuff
Public Const strCONN = "DRIVER={MySQL ODBC 5.1 Driver};SERVER=127.0.0.1;DATABASE=greentail;UID=root;PWD=changethis;OPTION=" & 1 + 2 + 8 + 32 + 2048 + 16384
'Connections....
Public Conn_Server As ADODB.Connection
Public Conn_Client As ADODB.Connection
'RecordSets
Public RS_LoadPlayer As ADODB.Recordset
Public RS_LoadChar As ADODB.Recordset
Public RS_SavePlayerNEW As ADODB.Recordset
Public RS_SavePlayerUPDATE As ADODB.Recordset
Public RS_SaveCharNEW As ADODB.Recordset
Public RS_SaveCharUPDATE As ADODB.Recordset
Dim RS_LOGS As ADODB.Recordset

Public Sub InitDB()
'Setup Connections
Set Conn_Client = New ADODB.Connection
Conn_Client.CursorLocation = adUseClient
Conn_Client.ConnectionString = strCONN
Conn_Client.Open

Set Conn_Server = New ADODB.Connection
Conn_Server.CursorLocation = adUseServer
Conn_Server.ConnectionString = strCONN
Conn_Server.Open

'Setup Connections

'Accounts
Set RS_SavePlayerNEW = New ADODB.Recordset
Set RS_SavePlayerUPDATE = New ADODB.Recordset
Set RS_LoadPlayer = New ADODB.Recordset
RS_SavePlayerNEW.Open "SELECT * FROM accounts LIMIT 1;", Conn_Client, adOpenStatic, adLockOptimistic

'Characters
Set RS_SaveCharNEW = New ADODB.Recordset
Set RS_SaveCharUPDATE = New ADODB.Recordset
Set RS_LoadChar = New ADODB.Recordset
RS_SaveCharNEW.Open "SELECT * FROM characters LIMIT 1;", Conn_Client, adOpenStatic, adLockOptimistic

'Logs
'Set RS_LOGS = New ADODB.Recordset
'RS_LOGS.Open "SELECT * FROM logs LIMIT 1;", Conn_Client, adOpenStatic, adLockOptimistic
End Sub

Public Sub CloseDB()
'Kill RecordSets

'Kill Logs
'RS_LOGS.Close
'Set RS_LOGS = Nothing

'Kill Characters
RS_SaveCharNEW.Close
Set RS_SaveCharNEW = Nothing
Set RS_SaveCharUPDATE = Nothing

'Kill Accounts
RS_SavePlayerNEW.Close
Set RS_SavePlayerNEW = Nothing
Set RS_SavePlayerUPDATE = Nothing

'Kill Connections
Conn_Server.Close
Set Conn_Server = Nothing
Conn_Client.Close
Set Conn_Client = Nothing
End Sub

Function GetVar(File As String, Header As String, Var As String) As String
Dim sSpaces As String   ' Max string length
Dim szReturn As String  ' Return default value if not found
  
    szReturn = vbNullString
  
    sSpaces = Space(5000)
  
    Call GetPrivateProfileString(Header, Var, szReturn, sSpaces, Len(sSpaces), File)
  
    GetVar = RTrim$(sSpaces)
    GetVar = Left(GetVar, Len(GetVar) - 1)
End Function

Function ExistVar(File As String, Header As String, Var As String) As String
Dim sSpaces As String   ' Max string length
Dim szReturn As String  ' Return default value if not found
  
    szReturn = "rib5239"
  
    sSpaces = Space(5000)
  
    Call GetPrivateProfileString(Header, Var, szReturn, sSpaces, Len(sSpaces), File)
  
    If RTrim$(sSpaces) = "rib5239" Then
        ExistVar = False
    Else
        ExistVar = True
    End If
End Function

Sub PutVar(File As String, Header As String, Var As String, Value As String)
    Call WritePrivateProfileString(Header, Var, Value, File)
End Sub

Public Sub DelVar(sFileName As String, sSection As String, sKey As String)

   If Len(Trim$(sKey)) <> 0 Then
      WritePrivateProfileString sSection, sKey, _
         vbNullString, sFileName
   Else
      WritePrivateProfileString _
         sSection, sKey, vbNullString, sFileName
   End If
End Sub

Sub LoadExps()
Dim FileName As String
Dim I As Long

    Call CheckExps
    
    FileName = App.Path & "\experience.ini"
    
    For I = 1 To MAX_LEVEL
        Call SetStatus("Loading exp... " & I & "/" & MAX_LEVEL)
        Experience(I) = GetVar(FileName, "EXPERIENCE", "Exp" & I)
        
        DoEvents
    Next I
End Sub

Sub CheckExps()
    If Not FileExist("experience.ini") Then
        Dim I As Long
    
        For I = 1 To MAX_LEVEL
            Call SetStatus("Saving exp... " & I & "/" & MAX_LEVEL)
            DoEvents
            Call PutVar(App.Path & "\experience.ini", "EXPERIENCE", "Exp" & I, I * 1500)
        Next I
    End If
End Sub

Sub ClearExps()
Dim I As Long

    For I = 1 To MAX_LEVEL
        Experience(I) = 0
    Next I
End Sub

Sub LoadEmos()
Dim FileName As String
Dim I As Long

    Call CheckEmos
    
    FileName = App.Path & "\emoticons.ini"
    
    For I = 0 To MAX_EMOTICONS
        Call SetStatus("Loading emoticons... " & I & "/" & MAX_EMOTICONS)
        Emoticons(I).Pic = GetVar(FileName, "EMOTICONS", "Emoticon" & I)
        Emoticons(I).Command = GetVar(FileName, "EMOTICONS", "EmoticonC" & I)
        
        DoEvents
    Next I
End Sub

Sub CheckEmos()
    If Not FileExist("emoticons.ini") Then
        Dim I As Long
    
        For I = 0 To MAX_EMOTICONS
            Call SetStatus("Saving emoticons... " & I & "/" & MAX_EMOTICONS)
            DoEvents
            Call PutVar(App.Path & "\emoticons.ini", "EMOTICONS", "Emoticon" & I, 0)
            Call PutVar(App.Path & "\emoticons.ini", "EMOTICONS", "EmoticonC" & I, vbNullString)
        Next I
    End If
End Sub

Sub ClearEmos()
Dim I As Long

    For I = 0 To MAX_EMOTICONS
        Emoticons(I).Pic = 0
        Emoticons(I).Command = vbNullString
    Next I
End Sub

Sub SaveEmoticon(ByVal EmoNum As Long)
Dim FileName As String

    FileName = App.Path & "\emoticons.ini"
    
    Call PutVar(FileName, "EMOTICONS", "EmoticonC" & EmoNum, Trim$(Emoticons(EmoNum).Command))
    Call PutVar(FileName, "EMOTICONS", "Emoticon" & EmoNum, Val(Emoticons(EmoNum).Pic))
End Sub

Function FileExist(ByVal FileName As String) As Boolean
    If Dir$(App.Path & "\" & FileName) = vbNullString Then
        FileExist = False
    Else
        FileExist = True
    End If
End Function

Public Function GetRecordCountByFKey(dbTable As String) As Long
Dim RS As ADODB.Recordset
Dim FKey As Long

'Setup database stuff
Set RS = New ADODB.Recordset
RS.Open "SELECT FKEY FROM " & dbTable & " ORDER BY FKey DESC LIMIT 1;", Conn_Server, adOpenStatic, adLockReadOnly

RS.MoveFirst
FKey = CLng(RS("FKey"))

RS.Close
Set RS = Nothing
GetRecordCountByFKey = FKey
End Function

Public Function Cleanse(Dirty As String) As String
'****************************************************************
'* WHEN        WHO        WHAT
'* ----        ---        ----
'* 11/15/2003  Shannara   Created Function
'****************************************************************

'THIS FUNCTION WILL ESCAPE ALL SINGLE QUOTE CHARACTERS IN AN EFFORT
'TO PREVENT SQL INJECTION ATTACKS. IT IS RECCOMENDED THAT ALL TAINTED DATA BE
'PASSED THROUGH THIS FUNCTION PRIOR TO BEING USED IN DYNAMIC SQL QUERIES.
'
'*******************************************
'NOTE: YOUR BROWSER MAY SHOW SPACES IN THE STRINGS (I.E.  " '  " ) THERE SHOULD BE NO WHITESPACES IN ANY OF THE STRINGS
'*******************************************
'
'WRITTEN BY: MIKE HILLYER
'LAST MODIFIED: 14JUN2003
    Cleanse = Replace(Dirty, "'", "\'")
'CLEVER HACKERS COULD PASS \' TO THIS FUNCTION, WHICH WOULD BECOME \\'
' \\' GETS INTERPRETED AS \', WITH THE \ BEING IGNORED AND THE ' GETTING
'INTERPRETED, THUS BYPASSING THIS FUNCTION, SO WE SHALL LOOP UNTIL WE ARE LEFT
'WITH JUST \' WHICH ESCAPES THE QUOTE, LOOP IS NEEDED BECAUSE A HACKER COULD TYPE
' \\\' IF WE SIMPLY CHECKED FOR \\' AFTER DOING THE INITIAL REPLACE.
    Do While InStr(Cleanse, "\\'")
        Cleanse = Replace(Cleanse, "\\'", "\'")
    Loop
End Function

Sub SaveAccount(ByVal index As Long)
Dim RS As ADODB.Recordset

'Save JUST Account
With Player(index)
    If .FKey = 0 Then
        'It is a new class, so we Insert.
        Set RS = RS_SavePlayerNEW
        RS.AddNew
    Else
        'It is an old class, so we update all fields.
        Set RS = RS_SavePlayerUPDATE
        RS.Open "SELECT * FROM accounts WHERE `FKey`=" & .FKey & ";", Conn_Client, adOpenStatic, adLockOptimistic
    End If
    RS!Login = Trim$(Player(index).Login)
    RS!Password = Encrypt(DBKEY, Trim$(Player(index).Password))
    RS!Email = Trim$(Player(index).Email)
    RS!Profile = ""
    RS.Update
    
    If .FKey = 0 Then
        'Grab New FKey
        .FKey = RS!FKey
    Else
        RS.Close
    End If
End With
End Sub

Sub SavePlayer(ByVal index As Long)
Dim FileName As String
Dim I As Long
Dim N As Long
'SQL Vars
Dim RS As ADODB.Recordset
Dim SPELLString As String
Dim INVString As String
Dim BANKString As String

'Do JUST Characters
For I = 1 To MAX_CHARS
    INVString = vbNullString
    SPELLString = vbNullString
    BANKString = vbNullString
    With Player(index).Char(I)
        If Trim$(.Name) <> vbNullString Then
            If .FKey = 0 Then
                'It is a new class, so we Insert.
                Set RS = RS_SaveCharNEW
                RS.AddNew
            Else
                'It is an old class, so we update all fields.
                Set RS = RS_SaveCharUPDATE
                RS.Open "SELECT * FROM characters WHERE `FKey`=" & .FKey & ";", Conn_Client, adOpenStatic, adLockOptimistic
                If RS.BOF And RS.EOF Then
                    RS.Close
                    Call HackingAttempt(index, "Del/Add Exploit")
                    Exit Sub
                End If
            End If
            RS!Account = Player(index).FKey
            RS!Name = Trim$(.Name)
            RS!Class = .Class
            RS!Sex = .Sex
            RS!Sprite = .Sprite
            RS!Level = .Level
            RS!Exp = .Exp
            RS!Access = .Access
            RS!PK = .PK
            RS!Guild = .Guild
            RS!Guildaccess = .Guildaccess
            RS!HP = .HP
            RS!MP = .MP
            RS!SP = .SP
            RS!STR = .STR
            RS!DEF = .DEF
            RS!Speed = .Speed
            RS!Magi = .Magi
            RS!POINTS = .POINTS
            RS!ArmorSlot = .ArmorSlot
            RS!WeaponSlot = .WeaponSlot
            RS!HelmetSlot = .HelmetSlot
            RS!ShieldSlot = .ShieldSlot
            RS!Map = .Map
            RS!X = .X
            RS!Y = .Y
            RS!Dir = .Dir
            
            'Inventory
            For N = 1 To MAX_INV
                INVString = INVString & .Inv(N).num & "."
                INVString = INVString & .Inv(N).Value & "."
                INVString = INVString & .Inv(N).Dur & "|"
            Next N
            RS!Inventory = INVString
    
            'Spells
            For N = 1 To MAX_PLAYER_SPELLS
                If N <> MAX_PLAYER_SPELLS Then
                    SPELLString = SPELLString & .Spell(N) & "."
                Else
                    SPELLString = SPELLString & .Spell(N)
                End If
            Next N
            RS!Spells = SPELLString
            
            'Bank
            For N = 1 To MAX_BANK
                BANKString = BANKString & .Bank(N).num & "."
                BANKString = BANKString & .Bank(N).Value & "."
                BANKString = BANKString & .Bank(N).Dur & "|"
            Next N
            RS!Bank = BANKString
            
            RS!LastIP = GetPlayerIP(index)
            'RS!Jailed = .Jailed
            
            RS.Update
            
            If .FKey = 0 Then
                'Grab New FKey
                .FKey = RS!FKey
            Else
                RS.Close
            End If
        End If
    End With
Next I
End Sub

Function GetProfile(ByVal Login As String)
'SQL Vars
Dim RS As ADODB.Recordset

    'Setup database stuff
    Set RS = RS_LoadPlayer
    RS.Open "SELECT * FROM accounts WHERE `login`='" & Trim$(Login) & "' LIMIT 1;", Conn_Server, adOpenStatic, adLockReadOnly
    RS.MoveFirst
    
    'Load Profile
    GetProfile = Trim$(CStr(RS("Profile")))
    
    RS.Close
End Function

Sub SetProfile(ByVal index As Long, Profile As String)
'SQL Vars
Dim RS As ADODB.Recordset

    'Setup database stuff
    Set RS = RS_SavePlayerUPDATE
    RS.Open "SELECT * FROM accounts WHERE `FKey`=" & Player(index).FKey & ";", Conn_Client, adOpenStatic, adLockOptimistic
    
    'Save Profile
    RS!Profile = Profile
    RS.Update
    
    RS.Close
End Sub

Sub LoadPlayer(ByVal index As Long, ByVal Name As String)
Dim FileName As String
Dim I As Long
Dim N As Long
'SQL Vars
Dim cCount As Long
Dim chCount As Long
Dim Inv1() As String
Dim Inv2() As String
Dim Bank1() As String
Dim Bank2() As String
Dim Spells() As String
Dim RS As ADODB.Recordset

    Call ClearPlayer(index)
    
    cCount = 0
    'Setup database stuff
    Set RS = RS_LoadPlayer
    RS.Open "SELECT * FROM accounts WHERE `login`='" & Trim$(Name) & "' LIMIT 1;", Conn_Server, adOpenStatic, adLockReadOnly
    RS.MoveFirst
    
    'Load Account
    With Player(index)
        .FKey = CLng(RS("FKey"))
        .Login = Trim$(CStr(RS("Login")))
        .Password = Decrypt(DBKEY, CStr(RS("Password")))
        .Email = Trim$(CStr(RS("Email")))
    End With
    RS.Close
    
    'Load Characters
    chCount = CharCount(Player(index).FKey)
    If chCount = 0 Then Exit Sub
    'Setup database stuff
    Set RS = RS_LoadChar
    RS.Open "SELECT * FROM characters WHERE `account`=" & Player(index).FKey & " LIMIT " & MAX_CHARS & ";", Conn_Server, adOpenStatic, adLockReadOnly
    RS.MoveFirst
    For I = 1 To chCount
        With Player(index).Char(I)
            ' General
            .FKey = CLng(RS("Fkey"))
            .Name = Trim$(CStr(RS("Name")))
            .Class = CByte(RS("Class"))
            .Sex = CByte(RS("Sex"))
            .Sprite = CInt(RS("Sprite"))
            .Level = CInt(RS("Level"))
            .Exp = CLng(RS("Exp"))
            .Access = CByte(RS("Access"))
            .PK = CByte(RS("PK"))
            .Guild = CStr(RS("Guild"))
            .Guildaccess = CByte(RS("GuildAccess"))
            
            ' Vitals
            .HP = CLng(RS("HP"))
            .MP = CLng(RS("MP"))
            .SP = CLng(RS("SP"))
            
            ' Stats
            .STR = CInt(RS("STR"))
            .DEF = CInt(RS("DEF"))
            .Speed = CInt(RS("SPEED"))
            .Magi = CInt(RS("MAGI"))
            .POINTS = CInt(RS("POINTS"))
            
            ' Worn equipment
            .ArmorSlot = CByte(RS("ArmorSlot"))
            .WeaponSlot = CByte(RS("WeaponSlot"))
            .HelmetSlot = CByte(RS("HelmetSlot"))
            .ShieldSlot = CByte(RS("ShieldSlot"))
            
            ' Position
            .Map = CInt(RS("Map"))
            .X = CByte(RS("X"))
            .Y = CByte(RS("Y"))
            .Dir = CByte(RS("Dir"))
            
            ' Check to make sure that they aren't on map 0, if so reset'm
            If .Map = 0 Then
                .Map = START_MAP
                .X = START_X
                .Y = START_Y
            End If
            
            ' Inventory
            Inv1 = Split(RS("Inventory"), "|")
            
            For N = 1 To MAX_INV
                Inv2 = Split(Inv1(N - 1), ".")
                .Inv(N).num = CLng(Inv2(0))
                .Inv(N).Value = CLng(Inv2(1))
                .Inv(N).Dur = CLng(Inv2(2))
            Next N
            
            ' Spells
            Spells = Split(RS("Spells"), ".")
            For N = 1 To MAX_PLAYER_SPELLS
                .Spell(N) = Spells(N - 1)
            Next N
            
            'Bank
            Bank1 = Split(RS("Bank"), "|")
            
            For N = 1 To MAX_BANK
                Bank2 = Split(Bank1(N - 1), ".")
                .Bank(N).num = CLng(Bank2(0))
                .Bank(N).Value = CLng(Bank2(1))
                .Bank(N).Dur = CLng(Bank2(2))
            Next N
        End With
        If I <> chCount Then
            RS.MoveNext
        End If
    Next I
    RS.Close
End Sub

Public Function CharCount(Account As Long) As Long
    'Setup database stuff
    Dim RS As ADODB.Recordset
    Dim I As Long
    Set RS = New ADODB.Recordset
    RS.Open "SELECT * FROM characters WHERE `account`=" & Account & " LIMIT " & MAX_CHARS & ";", Conn_Client, adOpenStatic, adLockReadOnly
    If Not (RS.BOF And RS.EOF) Then
    RS.MoveFirst
    I = RS.RecordCount
    CharCount = I
    Else
    CharCount = 0
    End If
    RS.Close
    Set RS = Nothing
End Function

Function AccountExist(ByVal Name As String) As Boolean
    Dim cLogin As String
    Dim iExist As Boolean
    Dim RS As ADODB.Recordset
    
    'Cleanse the strings
    cLogin = Cleanse(Trim$(Name))
    
    'Setup database stuff
    Set RS = New ADODB.Recordset
    RS.Open "SELECT * FROM accounts WHERE `login`='" & cLogin & "';", Conn_Server, adOpenStatic, adLockReadOnly
    
    iExist = False
    If Not (RS.BOF And RS.EOF) Then
        RS.MoveFirst
        iExist = True
    Else
        iExist = False
    End If
    RS.Close
    Set RS = Nothing
    AccountExist = iExist
End Function

Function CharExist(ByVal index As Long, ByVal CharNum As Long) As Boolean
    If Trim$(Player(index).Char(CharNum).Name) <> vbNullString Then
        CharExist = True
    Else
        CharExist = False
    End If
End Function

Function PasswordOK(ByVal Name As String, ByVal Password As String) As Boolean
Dim cLogin As String
Dim cPassword As String
Dim iExist As Boolean
Dim RS As ADODB.Recordset


'Cleanse the strings
cLogin = Cleanse(Trim$(Name))
cPassword = Encrypt(DBKEY, Trim$(Password))

'Setup database stuff
Set RS = New ADODB.Recordset
RS.Open "SELECT * FROM accounts WHERE `login`='" & cLogin & "' AND `password`='" & cPassword & "';", Conn_Server, adOpenStatic, adLockReadOnly

iExist = False
If Not (RS.BOF And RS.EOF) Then
    RS.MoveFirst
    iExist = True
Else
    iExist = False
End If
RS.Close

Set RS = Nothing
PasswordOK = iExist
End Function

Sub AddAccount(ByVal index As Long, ByVal Name As String, ByVal Password As String, ByVal Email As String)
Dim I As Long

    Player(index).Login = Name
    Player(index).Password = Password
    Player(index).Email = Email
    
    For I = 1 To MAX_CHARS
        Call ClearChar(index, I)
    Next I
    Call SaveAccount(index)
    Call SavePlayer(index)
End Sub

Sub AddChar(ByVal index As Long, ByVal Name As String, ByVal Sex As Byte, ByVal ClassNum As Byte, ByVal CharNum As Long)
Dim f As Long

    If Trim$(Player(index).Char(CharNum).Name) = vbNullString Then
        Player(index).CharNum = CharNum
        
        Player(index).Char(CharNum).Name = Name
        Player(index).Char(CharNum).Sex = Sex
        Player(index).Char(CharNum).Class = ClassNum
        
        If Player(index).Char(CharNum).Sex = SEX_MALE Then
            Player(index).Char(CharNum).Sprite = Class(ClassNum).MaleSprite
        Else
            Player(index).Char(CharNum).Sprite = Class(ClassNum).FemaleSprite
        End If
        
        Player(index).Char(CharNum).Level = 1
                    
        Player(index).Char(CharNum).STR = Class(ClassNum).STR
        Player(index).Char(CharNum).DEF = Class(ClassNum).DEF
        Player(index).Char(CharNum).Speed = Class(ClassNum).Speed
        Player(index).Char(CharNum).Magi = Class(ClassNum).Magi
        
        If Class(ClassNum).Map <= 0 Then Class(ClassNum).Map = 1
        If Class(ClassNum).X < 0 Or Class(ClassNum).X > MAX_MAPX Then Class(ClassNum).X = Int(Class(ClassNum).X / 2)
        If Class(ClassNum).Y < 0 Or Class(ClassNum).Y > MAX_MAPY Then Class(ClassNum).Y = Int(Class(ClassNum).Y / 2)
        Player(index).Char(CharNum).Map = Class(ClassNum).Map
        Player(index).Char(CharNum).X = Class(ClassNum).X
        Player(index).Char(CharNum).Y = Class(ClassNum).Y
            
        Player(index).Char(CharNum).HP = GetPlayerMaxHP(index)
        Player(index).Char(CharNum).MP = GetPlayerMaxMP(index)
        Player(index).Char(CharNum).SP = GetPlayerMaxSP(index)
        Exit Sub
    End If
End Sub

Sub DelChar(ByVal index As Long, ByVal CharNum As Long)

Call PutVar("pvppts.ini", "POINTS", GetPlayerName(index), 0)

    'Call DeleteName(Player(Index).Char(CharNum).Name)
    Call DeleteChar(Player(index).Char(CharNum).FKey)
    Call ClearChar(index, CharNum)
    'Call SavePlayer(Index)
End Sub

Function FindChar(ByVal Name As String) As Boolean
'NOTE: To find a character in the database list, to see if it already exists :)
Dim cLogin As String
Dim iExist As Boolean
Dim RS As ADODB.Recordset

'Cleanse the strings
cLogin = Cleanse(Trim$(Name))

'Setup database stuff
Set RS = New ADODB.Recordset
RS.Open "SELECT * FROM characters WHERE `name`='" & cLogin & "';", Conn_Server, adOpenStatic, adLockReadOnly

iExist = False
If Not (RS.BOF And RS.EOF) Then
    RS.MoveFirst
    iExist = True
Else
    iExist = False
End If
RS.Close
Set RS = Nothing
FindChar = iExist
End Function

Sub SaveAllPlayersOnline()
Dim I As Long

    For I = 1 To MAX_PLAYERS
        If IsPlaying(I) Then
            Call SavePlayer(I)
        End If
    Next I
End Sub

Sub LoadClasses()
Dim FileName As String
Dim I As Long

    Call CheckClasses
    
    FileName = App.Path & "\Classes\info.ini"
    
    Max_Classes = Val(GetVar(FileName, "INFO", "MaxClasses"))
    
    ReDim Class(0 To Max_Classes) As ClassRec
    
    Call ClearClasses
    
    For I = 0 To Max_Classes
        Call SetStatus("Loading classes... " & I & "/" & Max_Classes)
        FileName = App.Path & "\Classes\Class" & I & ".ini"
        Class(I).Name = GetVar(FileName, "CLASS", "Name")
        Class(I).MaleSprite = GetVar(FileName, "CLASS", "MaleSprite")
        Class(I).FemaleSprite = GetVar(FileName, "CLASS", "FemaleSprite")
        Class(I).STR = Val(GetVar(FileName, "CLASS", "STR"))
        Class(I).DEF = Val(GetVar(FileName, "CLASS", "DEF"))
        Class(I).Speed = Val(GetVar(FileName, "CLASS", "SPEED"))
        Class(I).Magi = Val(GetVar(FileName, "CLASS", "MAGI"))
        Class(I).Map = Val(GetVar(FileName, "CLASS", "MAP"))
        Class(I).X = Val(GetVar(FileName, "CLASS", "X"))
        Class(I).Y = Val(GetVar(FileName, "CLASS", "Y"))
        Class(I).Locked = Val(GetVar(FileName, "CLASS", "Locked"))
        
        DoEvents
    Next I
End Sub

Sub SaveClasses()
Dim FileName As String
Dim I As Long

    FileName = App.Path & "\Classes\info.ini"
    
    If Not FileExist("Classes\info.ini") Then
        Call PutVar(FileName, "INFO", "MaxClasses", 0)
        Call PutVar(FileName, "INFO", "MaxSkills", 25)
        Call PutVar(FileName, "INFO", "StatPoints", 0)
        Call PutVar(FileName, "INFO", "SkillPoints", 0)
    End If
    
    For I = 0 To Max_Classes
        Call SetStatus("Saving classes... " & I & "/" & Max_Classes)
        DoEvents
        FileName = App.Path & "\Classes\Class" & I & ".ini"
        If Not FileExist("Classes\Class" & I & ".ini") Then
            Call PutVar(FileName, "CLASS", "Name", Trim$(Class(I).Name))
            Call PutVar(FileName, "CLASS", "MaleSprite", STR(Class(I).MaleSprite))
            Call PutVar(FileName, "CLASS", "FemaleSprite", STR(Class(I).FemaleSprite))
            Call PutVar(FileName, "CLASS", "STR", STR(Class(I).STR))
            Call PutVar(FileName, "CLASS", "DEF", STR(Class(I).DEF))
            Call PutVar(FileName, "CLASS", "SPEED", STR(Class(I).Speed))
            Call PutVar(FileName, "CLASS", "MAGI", STR(Class(I).Magi))
            Call PutVar(FileName, "CLASS", "MAP", STR(Class(I).Map))
            Call PutVar(FileName, "CLASS", "X", STR(Class(I).X))
            Call PutVar(FileName, "CLASS", "Y", STR(Class(I).Y))
            Call PutVar(FileName, "CLASS", "Locked", STR(Class(I).Locked))
        End If
    Next I
End Sub

Sub CheckClasses()
    If Not FileExist("Classes\info.ini") Then
        Call SaveClasses
    End If
End Sub

Sub LoadClasses2()
Dim FileName As String
Dim I As Long

    Call CheckClasses2
    
    FileName = App.Path & "\FirstClassAdvancement.ini"
    
    Max_Classes = Val(GetVar(FileName, "INIT", "MaxClasses"))
    
    ReDim Class2(0 To Max_Classes) As ClassRec
    
    Call ClearClasses2
    
    For I = 0 To Max_Classes
        Call SetStatus("Loading first class advandcement... " & I & "/" & Max_Classes)
        Class2(I).Name = GetVar(FileName, "CLASS" & I, "Name")
        Class2(I).AdvanceFrom = Val(GetVar(FileName, "CLASS" & I, "AdvanceFrom"))
        Class2(I).MaleSprite = GetVar(FileName, "CLASS" & I, "MaleSprite")
        Class2(I).FemaleSprite = GetVar(FileName, "CLASS" & I, "FemaleSprite")
        Class2(I).STR = Val(GetVar(FileName, "CLASS" & I, "STR"))
        Class2(I).DEF = Val(GetVar(FileName, "CLASS" & I, "DEF"))
        Class2(I).Speed = Val(GetVar(FileName, "CLASS" & I, "SPEED"))
        Class2(I).Magi = Val(GetVar(FileName, "CLASS" & I, "MAGI"))
        
        DoEvents
    Next I
End Sub

Sub SaveClasses2()
Dim FileName As String
Dim I As Long

    FileName = App.Path & "\FirstClassAdvancement.ini"
    
    For I = 0 To Max_Classes
        Call SetStatus("Saving first class advandcement... " & I & "/" & Max_Classes)
        DoEvents
        Call PutVar(FileName, "CLASS" & I, "Name", Trim$(Class2(I).Name))
        Call PutVar(FileName, "CLASS" & I, "AdvanceFrom", STR(Class2(I).AdvanceFrom))
        Call PutVar(FileName, "CLASS" & I, "LevelReq", STR(Class2(I).LevelReq))
        Call PutVar(FileName, "CLASS" & I, "MaleSprite", STR(Class2(I).MaleSprite))
        Call PutVar(FileName, "CLASS" & I, "FemaleSprite", STR(Class2(I).FemaleSprite))
        Call PutVar(FileName, "CLASS" & I, "STR", STR(Class2(I).STR))
        Call PutVar(FileName, "CLASS" & I, "DEF", STR(Class2(I).DEF))
        Call PutVar(FileName, "CLASS" & I, "SPEED", STR(Class2(I).Speed))
        Call PutVar(FileName, "CLASS" & I, "MAGI", STR(Class2(I).Magi))
    Next I
End Sub

Sub CheckClasses2()
    If Not FileExist("FirstClassAdvancement.ini") Then
        Call SaveClasses2
    End If
End Sub

Sub Loadclasses3()
Dim FileName As String
Dim I As Long

    Call Checkclasses3
    
    FileName = App.Path & "\SecondClassAdvancement.ini"
    
    Max_Classes = Val(GetVar(FileName, "INIT", "MaxClasses"))
    
    ReDim Class3(0 To Max_Classes) As ClassRec
    
    Call ClearClasses3
    
    For I = 0 To Max_Classes
        Call SetStatus("Loading second class advandcement... " & I & "/" & Max_Classes)
        Class3(I).Name = GetVar(FileName, "CLASS" & I, "Name")
        Class3(I).AdvanceFrom = Val(GetVar(FileName, "CLASS" & I, "AdvanceFrom"))
        Class3(I).LevelReq = Val(GetVar(FileName, "CLASS" & I, "LevelReq"))
        Class3(I).MaleSprite = GetVar(FileName, "CLASS" & I, "MaleSprite")
        Class3(I).FemaleSprite = GetVar(FileName, "CLASS" & I, "FemaleSprite")
        Class3(I).STR = Val(GetVar(FileName, "CLASS" & I, "STR"))
        Class3(I).DEF = Val(GetVar(FileName, "CLASS" & I, "DEF"))
        Class3(I).Speed = Val(GetVar(FileName, "CLASS" & I, "SPEED"))
        Class3(I).Magi = Val(GetVar(FileName, "CLASS" & I, "MAGI"))
        
        DoEvents
    Next I
End Sub

Sub Saveclasses3()
Dim FileName As String
Dim I As Long

    FileName = App.Path & "\SecondClassAdvancement.ini"
    
    For I = 0 To Max_Classes
        Call SetStatus("Saving second class advandcement... " & I & "/" & Max_Classes)
        DoEvents
        Call PutVar(FileName, "CLASS" & I, "Name", Trim$(Class3(I).Name))
        Call PutVar(FileName, "CLASS" & I, "AdvanceFrom", STR(Class3(I).AdvanceFrom))
        Call PutVar(FileName, "CLASS" & I, "MaleSprite", STR(Class3(I).MaleSprite))
        Call PutVar(FileName, "CLASS" & I, "FemaleSprite", STR(Class3(I).FemaleSprite))
        Call PutVar(FileName, "CLASS" & I, "STR", STR(Class3(I).STR))
        Call PutVar(FileName, "CLASS" & I, "DEF", STR(Class3(I).DEF))
        Call PutVar(FileName, "CLASS" & I, "SPEED", STR(Class3(I).Speed))
        Call PutVar(FileName, "CLASS" & I, "MAGI", STR(Class3(I).Magi))
    Next I
End Sub

Sub Checkclasses3()
    If Not FileExist("SecondClassAdvancement.ini") Then
        Call Saveclasses3
    End If
End Sub

Sub SaveItems()
Dim I As Long
        
    Call SetStatus("Saving items... ")
    For I = 1 To MAX_ITEMS
        If Not FileExist("items\item" & I & ".dat") Then
            Call SetStatus("Saving items... " & I & "/" & MAX_ITEMS)
            DoEvents
            Call SaveItem(I)
        End If
    Next I
End Sub

Sub SaveItem(ByVal ItemNum As Long)
Dim FileName As String
Dim f  As Long
FileName = App.Path & "\items\item" & ItemNum & ".dat"
        
    f = FreeFile
    Open FileName For Binary As #f
        Put #f, , Item(ItemNum)
    Close #f
End Sub

Sub LoadItems()
Dim FileName As String
Dim I As Long
Dim f As Long

    Call CheckItems
    
    For I = 1 To MAX_ITEMS
        Call SetStatus("Loading items... " & I & "/" & MAX_ITEMS)
        
        FileName = App.Path & "\Items\Item" & I & ".dat"
        f = FreeFile
        Open FileName For Binary As #f
            Get #f, , Item(I)
        Close #f
        
        DoEvents
    Next I
End Sub

Sub ClearParties()
    Dim I, o As Long

    For I = 1 To MAX_PARTIES
        For o = 1 To MAX_PARTY_MEMBERS
            Party(I).Member(o) = 0
        Next
    Next

End Sub

Sub CheckItems()
    Call SaveItems
End Sub

Sub SaveShops()
Dim I As Long

    Call SetStatus("Saving shops... ")
    For I = 1 To MAX_SHOPS
        If Not FileExist("shops\shop" & I & ".dat") Then
            Call SetStatus("Saving shops... " & I & "/" & MAX_SHOPS)
            DoEvents
            Call SaveShop(I)
        End If
    Next I
End Sub

Sub SaveShop(ByVal ShopNum As Long)
Dim FileName As String
Dim f As Long

    FileName = App.Path & "\shops\shop" & ShopNum & ".dat"
        
    f = FreeFile
    Open FileName For Binary As #f
        Put #f, , Shop(ShopNum)
    Close #f
End Sub

Sub LoadShops()
Dim FileName As String
Dim I As Long, f As Long

    Call CheckShops
    
    For I = 1 To MAX_SHOPS
        Call SetStatus("Loading shops... " & I & "/" & MAX_SHOPS)
        FileName = App.Path & "\shops\shop" & I & ".dat"
        f = FreeFile
        Open FileName For Binary As #f
            Get #f, , Shop(I)
        Close #f
        
        DoEvents
    Next I
End Sub

Sub LoadSpeeches()
    Dim FileName As String
    Dim I As Long
    Dim f As Long

    Call CheckSpeech

    For I = 1 To MAX_SPEECH
        Call SetStatus("Loading speech... " & Int((I / MAX_SPEECH) * 100) & "%")
        FileName = App.Path & "\speech\speech" & I & ".dat"
        f = FreeFile
        Open FileName For Binary As #f
        Get #f, , Speech(I)
        Close #f

        DoEvents
    Next

End Sub

Sub SaveSpeech(ByVal index As Long)
    Dim FileName As String
    Dim f As Long

    FileName = App.Path & "\speech\speech" & index & ".dat"
    f = FreeFile
    Open FileName For Binary As #f
    Put #f, , Speech(index)
    Close #f
End Sub

Sub SaveSpeeches()
    Dim I As Long

    Call SetStatus("Saving speech... ")

    For I = 1 To MAX_SPEECH

        If Not FileExist("speech\speech" & I & ".dat") Then
            Call SetStatus("Saving speech... " & Int((I / MAX_SPEECH) * 100) & "%")

            DoEvents
            Call SaveSpeech(I)
        End If

    Next

End Sub

Sub CheckShops()
    Call SaveShops
End Sub

Sub CheckSpeech()
    Call SaveSpeeches
End Sub

Sub SaveSpell(ByVal SpellNum As Long)
Dim FileName As String
Dim f As Long

    FileName = App.Path & "\spells\spells" & SpellNum & ".dat"
        
    f = FreeFile
    Open FileName For Binary As #f
        Put #f, , Spell(SpellNum)
    Close #f
End Sub

Sub SaveSpells()
Dim I As Long

    Call SetStatus("Saving spells... ")
    For I = 1 To MAX_SPELLS
        If Not FileExist("spells\spells" & I & ".dat") Then
            Call SetStatus("Saving spells... " & I & "/" & MAX_SPELLS)
            DoEvents
            Call SaveSpell(I)
        End If
    Next I
End Sub

Sub LoadSpells()
Dim FileName As String
Dim I As Long
Dim f As Long

    Call CheckSpells
    
    For I = 1 To MAX_SPELLS
        Call SetStatus("Loading spells... " & I & "/" & MAX_SPELLS)
        
        FileName = App.Path & "\spells\spells" & I & ".dat"
        f = FreeFile
        Open FileName For Binary As #f
            Get #f, , Spell(I)
        Close #f
        
        DoEvents
    Next I
End Sub

Sub CheckSpells()
    Call SaveSpells
End Sub

Sub SaveNpcs()
Dim I As Long

    Call SetStatus("Saving npcs... ")
    
    For I = 1 To MAX_NPCS
        If Not FileExist("npcs\npc" & I & ".dat") Then
            Call SetStatus("Saving npcs... " & I & "/" & MAX_NPCS)
            DoEvents
            Call SaveNpc(I)
        End If
    Next I
End Sub

Sub SaveNpc(ByVal NpcNum As Long)
Dim FileName As String
Dim f As Long
FileName = App.Path & "\npcs\npc" & NpcNum & ".dat"
        
    f = FreeFile
    Open FileName For Binary As #f
        Put #f, , Npc(NpcNum)
    Close #f
End Sub

Sub LoadNpcs()
Dim FileName As String
Dim I As Long
Dim z As Long
Dim f As Long

    Call CheckNpcs
        
    For I = 1 To MAX_NPCS
        Call SetStatus("Loading npcs... " & I & "/" & MAX_NPCS)
        FileName = App.Path & "\npcs\npc" & I & ".dat"
        f = FreeFile
        Open FileName For Binary As #f
            Get #f, , Npc(I)
        Close #f
        
        DoEvents
    Next I
End Sub

Sub CheckNpcs()
    Call SaveNpcs
End Sub

Sub SaveMap(ByVal MapNum As Long)
Dim FileName As String
Dim f As Long

    FileName = App.Path & "\maps\map" & MapNum & ".dat"
        
    f = FreeFile
    Open FileName For Binary As #f
        Put #f, , Map(MapNum)
    Close #f
End Sub

Sub LoadMaps()
Dim FileName As String
Dim I As Long
Dim f As Long

    Call CheckMaps
    
    For I = 1 To MAX_MAPS
        Call SetStatus("Loading maps... " & I & "/" & MAX_MAPS)
        FileName = App.Path & "\maps\map" & I & ".dat"
        
        f = FreeFile
        Open FileName For Binary As #f
            Get #f, , Map(I)
        Close #f
    
        DoEvents
    Next I
End Sub

Sub CheckMaps()
Dim FileName As String
Dim X As Long
Dim Y As Long
Dim I As Long
Dim N As Long

    Call ClearMaps
        
    For I = 1 To MAX_MAPS
        FileName = "maps\map" & I & ".dat"
        
        ' Check to see if map exists, if it doesn't, create it.
        If Not FileExist(FileName) Then
            Call SetStatus("Saving maps... " & I & "/" & MAX_MAPS)
            DoEvents
            
            Call SaveMap(I)
        End If
    Next I
End Sub

Sub AddLog(ByVal Text As String, ByVal FN As String)
Dim FileName As String
Dim f As Long

    If ServerLog = True Then
        FileName = App.Path & "\" & FN
    
        If Not FileExist(FN) Then
            f = FreeFile
            Open FileName For Output As #f
            Close #f
        End If
    
        f = FreeFile
        Open FileName For Append As #f
            Print #f, Time & ": " & Text
        Close #f
    End If
End Sub

Sub BanIndex(ByVal BanPlayerIndex As Long, ByVal BannedByIndex As Long)
Dim FileName, IP As String
Dim f As Long, I As Long

    FileName = App.Path & "\banlist.txt"
    
    ' Make sure the file exists
    If Not FileExist("banlist.txt") Then
        f = FreeFile
        Open FileName For Output As #f
        Close #f
    End If
    
    ' Cut off last portion of ip
    IP = GetPlayerIP(BanPlayerIndex)
            
    For I = Len(IP) To 1 Step -1
        If Mid(IP, I, 1) = "." Then
            Exit For
        End If
    Next I
    IP = Mid$(IP, 1, I)
            
    f = FreeFile
    Open FileName For Append As #f
        Print #f, IP & "," & GetPlayerName(BannedByIndex)
    Close #f
    
    Call GlobalMsg(GetPlayerName(BanPlayerIndex) & " has been banned from " & GAME_NAME & " by " & GetPlayerName(BannedByIndex) & "!", White)
    Call AddLog(GetPlayerName(BannedByIndex) & " has banned " & GetPlayerName(BanPlayerIndex) & ".", ADMIN_LOG)
    Call AlertMsg(BanPlayerIndex, "You have been banned by " & GetPlayerName(BannedByIndex) & "!")
End Sub

Sub DeleteAccount(FKey As Long)
    Call Conn_Server.Execute("DELETE FROM accounts WHERE `fkey`=" & FKey & ";")
End Sub

Sub DeleteChar(FKey As Long)
    Call Conn_Server.Execute("DELETE FROM characters WHERE `fkey`=" & FKey & ";")
End Sub

Sub BanByServer(ByVal BanPlayerIndex As Long, ByVal Reason As String)
Dim FileName, IP As String
Dim f As Long, I As Long

    FileName = App.Path & "\banlist.txt"
    
    ' Make sure the file exists
    If Not FileExist("banlist.txt") Then
        f = FreeFile
        Open FileName For Output As #f
        Close #f
    End If
    
    ' Cut off last portion of ip
    IP = GetPlayerIP(BanPlayerIndex)
    
    For I = Len(IP) To 1 Step -1
        If Mid$(IP, I, 1) = "." Then
            Exit For
        End If
    Next I
    IP = Mid$(IP, 1, I)
            
    f = FreeFile
    Open FileName For Append As #f
        Print #f, IP & "," & "Server"
    Close #f
    
    If Trim$(Reason) <> vbNullString Then
        Call GlobalMsg(GetPlayerName(BanPlayerIndex) & " has been banned from " & GAME_NAME & " by the server! Reason(" & Reason & ")", White)
        Call AlertMsg(BanPlayerIndex, "You have been banned by the server!  Reason(" & Reason & ")")
        Call AddLog("The server has banned " & GetPlayerName(BanPlayerIndex) & ".  Reason(" & Reason & ")", ADMIN_LOG)
    Else
        Call GlobalMsg(GetPlayerName(BanPlayerIndex) & " has been banned from " & GAME_NAME & " by the server!", White)
        Call AlertMsg(BanPlayerIndex, "You have been banned by the server!")
        Call AddLog("The server has banned " & GetPlayerName(BanPlayerIndex) & ".", ADMIN_LOG)
    End If
End Sub

Sub LoadArrows()
Dim FileName As String
Dim I As Long

    Call CheckArrows
    
    FileName = App.Path & "\Arrows.ini"
    
    For I = 1 To MAX_ARROWS
        Call SetStatus("Loading Arrows... " & I & "/" & MAX_ARROWS)
        Arrows(I).Name = GetVar(FileName, "Arrow" & I, "ArrowName")
        Arrows(I).Pic = GetVar(FileName, "Arrow" & I, "ArrowPic")
        Arrows(I).Range = GetVar(FileName, "Arrow" & I, "ArrowRange")
        Arrows(I).Amount = GetVar(FileName, "Arrow" & I, "ArrowAmount")

        DoEvents
    Next I
End Sub

Sub CheckArrows()
    If Not FileExist("Arrows.ini") Then
        Dim I As Long
    
        For I = 1 To MAX_ARROWS
            Call SetStatus("Saving arrows... " & I & "/" & MAX_ARROWS)
            DoEvents
            Call PutVar(App.Path & "\Arrows.ini", "Arrow" & I, "ArrowName", vbNullString)
            Call PutVar(App.Path & "\Arrows.ini", "Arrow" & I, "ArrowPic", 0)
            Call PutVar(App.Path & "\Arrows.ini", "Arrow" & I, "ArrowRange", 0)
            Call PutVar(App.Path & "\Arrows.ini", "Arrow" & I, "ArrowAmount", 0)
        Next I
    End If
End Sub

Sub ClearArrows()
Dim I As Long

    For I = 1 To MAX_ARROWS
        Arrows(I).Name = vbNullString
        Arrows(I).Pic = 0
        Arrows(I).Range = 0
        Arrows(I).Amount = 0
    Next I
End Sub

Sub SaveArrow(ByVal ArrowNum As Long)
Dim FileName As String

    FileName = App.Path & "\Arrows.ini"
    
    Call PutVar(FileName, "Arrow" & ArrowNum, "ArrowName", Trim$(Arrows(ArrowNum).Name))
    Call PutVar(FileName, "Arrow" & ArrowNum, "ArrowPic", Val(Arrows(ArrowNum).Pic))
    Call PutVar(FileName, "Arrow" & ArrowNum, "ArrowRange", Val(Arrows(ArrowNum).Range))
    Call PutVar(FileName, "Arrow" & ArrowNum, "ArrowAmount", Val(Arrows(ArrowNum).Amount))
End Sub
